Option Compare Database
Option Explicit

Function RunSub()
    BackUp
End Function

Sub BackUp()
    Dim dTime As Date
    On Error Resume Next
    dTime = InputBox("Create a backup at", , Time + TimeValue("00:00:05"))
    If err.Number <> 0 Then Exit Sub
    Do Until Time = dTime
        DoEvents
    Loop
    MsgBox "Time to create a backup"

    Dim sFile As String, oDB As DAO.Database
    sFile = CurrentProject.Path & "\" & Format(Date, "m-d-yy") & ".accdb"
    If Dir(sFile) <> "" Then Kill sFile
    Set oDB = DBEngine.Workspaces(0).CreateDatabase(sFile, dbLangGeneral)
    oDB.Close
    DoCmd.Hourglass True
    
    Dim oTD As TableDef
    For Each oTD In CurrentDb.TableDefs
        If left(oTD.Name, 4) <> "MSys" Then
               DoCmd.CopyObject sFile, , acTable, oTD.Name
               'OR: DoCmd.TransferDatabase   acExport, "Microsoft Access", sFile, acTable, oTD.Name, oTD.Name
        End If
    Next oTD
    
    'Dim oQD As QueryDef
    'For Each oQD In CurrentDb.QueryDefs
        'If Left(oQD.Name, 1) <> "~" Then
               'DoCmd.CopyObject sFile, , acQuery, oQD.Name
        'End If
    'Next oQD
    
    'Dim oForm As Object
    'For Each oForm In CurrentProject.AllForms
         'DoCmd.CopyObject sFile, , acForm, oForm.Name
    'Next oForm
    
    'Dim oMod As Object
    'For Each oMod In CurrentProject.AllModules
         'DoCmd.CopyObject sFile, , acModule, oMod.Name
    'Next oMod
    
    DoCmd.Hourglass False
    MsgBox "Backup is stored in the same folder"
End Sub


